home *** CD-ROM | disk | FTP | other *** search
/ FishMarket 1.0 / FishMarket v1.0.iso / fishies / 501-525 / disk_525 / siod / pratt.scm < prev    next >
Lisp/Scheme  |  1992-05-06  |  7KB  |  323 lines
  1. ;; -*-mode:lisp-*-
  2. ;;
  3. ;; A simple Pratt-Parser for SIOD: 2-FEB-90, George Carrette, GJC@PARADIGM.COM
  4. ;; Siod version 2.4 may be obtained by anonymous FTP to BU.EDU (128.197.2.6)
  5. ;; Get the file users/gjc/siod-v2.4-shar
  6. ;;
  7. ;;                   COPYRIGHT (c) 1990 BY                       
  8. ;;     PARADIGM ASSOCIATES INCORPORATED, CAMBRIDGE, MASSACHUSETTS.
  9. ;;         See the source file SLIB.C for more information. 
  10. ;;
  11. ;;
  12. ;; Based on a theory of parsing presented in:                       
  13. ;;                                                                      
  14. ;;  Pratt, Vaughan R., ``Top Down Operator Precedence,''         
  15. ;;  ACM Symposium on Principles of Programming Languages         
  16. ;;  Boston, MA; October, 1973.                                   
  17. ;;                                                                      
  18.  
  19. ;; The following terms may be useful in deciphering this code:
  20.  
  21. ;; NUD -- NUll left Denotation (op has nothing to its left (prefix))
  22. ;; LED -- LEft Denotation      (op has something to left (postfix or infix))
  23.  
  24. ;; LBP -- Left Binding Power  (the stickiness to the left)
  25. ;; RBP -- Right Binding Power (the stickiness to the right)
  26. ;;
  27. ;;
  28.  
  29. ;; Example calls
  30. ;;
  31. ;; (pl '(f [ a ] = a + b / c)) => (= (f a) (+ a (/ b c)))
  32. ;;
  33. ;; (pl '(if g [ a COMMA b ] then a > b else k * c + a * b))
  34. ;;  => (if (g a b) (> a b) (+ (* k c) (* a b)))
  35. ;;
  36. ;; Notes: 
  37. ;;
  38. ;;   This code must be used with siod.scm loaded, in siod version 2.3
  39. ;;
  40. ;;   For practical use you will want to write some code to
  41. ;;   break up input into tokens.
  42.  
  43.  
  44. (defvar *eof* (list '*eof*))
  45.  
  46. ;; 
  47.  
  48. (defun pl (l)
  49.   ;; parse a list of tokens
  50.   (setq l (append l '($)))
  51.   (toplevel-parse (lambda (op arg)
  52.             (cond ((eq op 'peek)
  53.                (if l (car l) *eof*))
  54.               ((eq op 'get)
  55.                (if l (pop l) *eof*))
  56.               ((eq op 'unget)
  57.                (push arg l))))))
  58.  
  59. (defun peek-token (stream)
  60.   (stream 'peek nil))
  61.  
  62. (defun read-token (stream)
  63.   (stream 'get nil))
  64.  
  65. (defun unread-token (x stream)
  66.   (stream 'unget x))
  67.    
  68. (defun toplevel-parse (stream)
  69.   (if (eq *eof* (peek-token stream))
  70.       (read-token stream)
  71.     (parse -1 stream)))
  72.  
  73. (defun get (sym key)
  74.   ;; symbolconc takes the place of an explicit hash-table
  75.   (setq sym (symbolconc sym '+INTERNAL-PLIST))
  76.   (and (symbol-bound? sym)
  77.        (cdr (assq key (symbol-value sym)))))
  78.  
  79. (defun putprop (sym val key)
  80.   (set-cdr! (let ((cell (symbolconc sym '+INTERNAL-PLIST)))
  81.           (or (assq key (if (symbol-bound? cell)
  82.                 (symbol-value cell)
  83.                   (set-symbol-value! cell nil)))
  84.           (car (set-symbol-value! cell
  85.                       (cons (list key)
  86.                         (symbol-value cell))))))
  87.         val))
  88.  
  89. (defun plist (sym)
  90.   (setq sym (symbolconc sym '+INTERNAL-PLIST))
  91.   (and (symbol-bound? sym)
  92.        (symbol-value sym)))
  93.  
  94.  
  95. (defun value-if-symbol (x)
  96.   (if (symbol? x)
  97.       (symbol-value x)
  98.     x))
  99.  
  100. (defun nudcall (token stream)
  101.   (if (symbol? token)
  102.       (if (get token 'nud)
  103.       ((value-if-symbol (get token 'nud)) token stream)
  104.     (if (get token 'led)
  105.         (error 'not-a-prefix-operator token)
  106.       token)
  107.     token)
  108.     token))
  109.  
  110. (defun ledcall (token left stream)
  111.   ((value-if-symbol (or (and (symbol? token)
  112.                  (get token 'led))
  113.             (error 'not-an-infix-operator token)))
  114.    token
  115.    left
  116.    stream))
  117.  
  118.  
  119. (defun lbp (token)
  120.   (or (and (symbol? token) (get token 'lbp))
  121.       200))
  122.  
  123. (defun rbp (token)
  124.   (or (and (symbol? token) (get token 'rbp))
  125.       200))
  126.  
  127. (defvar *parse-debug* nil)
  128.  
  129. (defun parse (rbp-level stream)
  130.   (if *parse-debug* (print `(parse ,rbp-level)))
  131.   (defun parse-loop (translation)
  132.     (if (< rbp-level (lbp (peek-token stream)))
  133.     (parse-loop (ledcall (read-token stream) translation stream))
  134.       (begin (if *parse-debug* (print translation))
  135.          translation)))
  136.   (parse-loop (nudcall (read-token stream) stream)))
  137.  
  138. (defun header (token)
  139.   (or (get token 'header) token))
  140.  
  141. (defun parse-prefix (token stream)
  142.   (list (header token)
  143.     (parse (rbp token) stream)))
  144.  
  145. (defun parse-infix (token left stream)
  146.   (list (header token)
  147.     left
  148.     (parse (rbp token) stream)))
  149.  
  150. (defun parse-nary (token left stream)
  151.   (cons (header token) (cons left (prsnary token stream))))
  152.  
  153. (defun parse-matchfix (token left stream)
  154.   (cons (header token)
  155.     (prsmatch (or (get token 'match) token)
  156.           stream)))
  157.  
  158. (defun prsnary (token stream)
  159.   (defun loop (l)
  160.     (if (eq? token (peek-token stream))
  161.     (begin (read-token stream)
  162.            (loop (cons (parse (rbp token) stream) l)))
  163.       (reverse l)))
  164.   (loop (list (parse (rbp token) stream))))
  165.  
  166. (defun prsmatch (token stream)
  167.   (if (eq? token (peek-token stream))
  168.       (begin (read-token stream)
  169.          nil)
  170.     (begin (defun loop (l)
  171.          (if (eq? token (peek-token stream))
  172.          (begin (read-token stream)
  173.             (reverse l))
  174.            (if (eq? 'COMMA (peek-token stream))
  175.            (begin (read-token stream)
  176.               (loop (cons (parse 10 stream) l)))
  177.          (error 'comma-or-match-not-found (read-token stream)))))
  178.        (loop (list (parse 10 stream))))))
  179.  
  180. (defun delim-err (token stream)
  181.   (error 'illegal-use-of-delimiter token))
  182.  
  183. (defun erb-error (token left stream)
  184.   (error 'too-many token))
  185.  
  186. (defun premterm-err (token stream)
  187.   (error 'premature-termination-of-input token))
  188.  
  189. (defmac (defprops form)
  190.   (defun loop (l result)
  191.     (if (null? l)
  192.     `(begin ,@result)
  193.       (loop (cddr l)
  194.         `((putprop ',(cadr form) ',(cadr l) ',(car l))
  195.           ,@result))))
  196.   (loop (cddr form) nil))
  197.  
  198.  
  199. (defprops $
  200.   lbp -1
  201.   nud premterm-err)
  202.  
  203. (defprops COMMA
  204.   lbp 10
  205.   nud delim-err)
  206.  
  207.  
  208. (defprops ]
  209.   nud delim-err
  210.   led erb-err
  211.   lbp 5)
  212.  
  213. (defprops [
  214.   nud open-paren-nud
  215.   led open-paren-led
  216.   lbp 200)
  217.  
  218. (defprops if
  219.   nud if-nud
  220.   rbp 45)
  221.  
  222. (defprops then
  223.   nud delim-err
  224.   lbp 5
  225.   rbp 25)
  226.  
  227. (defprops else
  228.   nud delim-err
  229.   lbp 5
  230.   rbp 25)
  231.  
  232. (defprops -
  233.   nud parse-prefix
  234.   led parse-nary
  235.   lbp 100
  236.   rbp 100)
  237.  
  238. (defprops +
  239.   nud parse-prefix
  240.   led parse-nary
  241.   lbp 100
  242.   rbp 100)
  243.  
  244. (defprops *
  245.   led parse-nary
  246.   lbp 120)
  247.  
  248. (defprops =
  249.   led parse-infix
  250.   lbp 80
  251.   rbp 80)
  252.  
  253. (defprops **
  254.   lbp 140
  255.   rbp 139
  256.   led parse-infix)
  257.  
  258. (defprops :=
  259.   led parse-infix
  260.   lbp 80
  261.   rbp 80)
  262.  
  263.  
  264. (defprops /
  265.   led parse-infix
  266.   lbp 120
  267.   rbp 120)
  268.  
  269. (defprops >
  270.   led parse-infix
  271.   lbp 80
  272.   rbp 80)
  273.  
  274. (defprops <
  275.   led parse-infix
  276.   lbp 80
  277.   rbp 80)
  278.  
  279. (defprops >=
  280.   led parse-infix
  281.   lbp 80
  282.   rbp 80)
  283.  
  284. (defprops <=
  285.   led parse-infix
  286.   lbp 80
  287.   rbp 80)
  288.  
  289. (defprops not
  290.   nud parse-prefix
  291.   lbp 70
  292.   rbp 70)
  293.  
  294. (defprops and
  295.   led parse-nary
  296.   lbp 65)
  297.  
  298. (defprops or
  299.   led parse-nary
  300.   lbp 60)
  301.  
  302.  
  303. (defun open-paren-nud (token stream)
  304.   (if (eq (peek-token stream) '])
  305.       nil
  306.     (let ((right (prsmatch '] stream)))
  307.       (if (cdr right)
  308.       (cons 'sequence right)
  309.     (car right)))))
  310.  
  311. (defun open-paren-led (token left stream)
  312.   (cons (header left) (prsmatch '] stream)))
  313.  
  314.  
  315. (defun if-nud (token stream)
  316.   (define pred (parse (rbp token) stream))
  317.   (define then (if (eq? (peek-token stream) 'then)
  318.            (parse (rbp (read-token stream)) stream)
  319.          (error 'missing-then)))
  320.   (if (eq? (peek-token stream) 'else)
  321.       `(if ,pred ,then ,(parse (rbp (read-token stream)) stream))
  322.     `(if ,pred ,then)))
  323.